home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / HUNCHY.ZIP / HPLAY.INC < prev    next >
Encoding:
Text File  |  1980-01-01  |  3.4 KB  |  140 lines
  1. procedure InitPlay;
  2. begin
  3.   Octave:=2;
  4.   AllLength:=1/4;
  5.   Tempo:=120;
  6.   Music:=7/8;
  7.   Step:=True;
  8. end;
  9.  
  10. procedure Play(ComLin:Str255);
  11. type
  12.   ChrSet=set of char;
  13. const
  14.   Comms:ChrSet=['L','M','N','<','>','O','P','S','T'];
  15.   Notes:ChrSet=['A'..'G'];
  16.   Appix:ChrSet=['#','+','-','.'];
  17.   Numbers:ChrSet=['0'..'9'];
  18. var
  19.   Ctr:integer;
  20.   ComLinPos:byte;
  21.   Command:Str255;
  22.  
  23.   procedure NoSpaces(var Lin:Str255);
  24.   var Tmp:Str255;
  25.       Ctr:byte;
  26.   begin
  27.     Tmp:='';
  28.     for Ctr:=1 to Length(Lin) do
  29.       if not(Lin[Ctr] in [' ',',']) then Tmp:=Tmp + UpCase(Lin[Ctr]);
  30.     Lin:=Tmp;
  31.   end;
  32.  
  33.   function GetSymbol(Lin:Str255; LinPos:byte; TrmSet:ChrSet):Str255;
  34.   var ComLen:byte;
  35.   begin
  36.     GetSymbol:='';
  37.     if Lin [LinPos] in TrmSet then begin
  38.       ComLen:=1;
  39.       while not(Lin [LinPos+ComLen] in TrmSet) and
  40.             not(LinPos+ComLen>255) do Inc(ComLen);
  41.       GetSymbol:=Copy(Lin,LinPos,ComLen);
  42.     end;
  43.   end;
  44.  
  45.   function GetNumber(Lin:Str255; var LinPos:byte):integer;
  46.   var ComLen:byte;
  47.       Code,Tmp:integer;
  48.   begin
  49.     Tmp:=0;
  50.     ComLen:=1;
  51.     while Lin [LinPos+ComLen] in Numbers do
  52.       Inc(ComLen);
  53.     Val(Copy(Lin,LinPos,ComLen),Tmp,Code);
  54.     Inc(LinPos,ComLen-1);
  55.     GetNumber:=Tmp;
  56.   end;
  57.  
  58.   procedure ProcessCommand(Com:Str255);
  59.   var ThisLen:real;
  60.       p:byte;
  61.   begin
  62.     p:=2;
  63.     case Com[1] of
  64.       'L':AllLength:=1/GetNumber(Com,p);
  65.       '<':if Octave > 0 then Dec(Octave);
  66.       '>':if Octave < 9 then Inc(Octave);
  67.       'O':Octave:=GetNumber(Com,p);
  68.       'P':begin
  69.         NoSound;
  70.         ThisLen:=AllLength;
  71.         if Length(Com)>1 then ThisLen:=1/GetNumber(Com,p);
  72.         Delay(Round(ThisLen*(256-Tempo)*15));
  73.       end;
  74.       'T':Tempo:=GetNumber(Com,p);
  75.       'M':case Com[2] of
  76.         '7':Music:=7/8;
  77.         '1':Music:=1;
  78.         '3':Music:=3/4;
  79.       end;
  80.       'S':Step:=Boolean(Ord(Com[2])-48);
  81.     end;
  82.   end;
  83.  
  84.   procedure PlayNote(Com:Str255);
  85.   var Ctr,ThisOct:byte;
  86.       Frequency,ThisLen:real;
  87.       Note,Dummy:integer;
  88.   begin
  89.     ThisOct:=Octave;
  90.     ThisLen:=AllLength;
  91.     Note:=Pos(Com[1], 'C D EF G A B');
  92.     Ctr:=2;
  93.     while Ctr <= Length(Com) do begin
  94.       case Com[Ctr] of
  95.         '#','+':Inc(Note);
  96.             '-':Dec(Note);
  97.             '.':ThisLen:=ThisLen * 3/2;
  98.        '0'..'9':ThisLen:=1/GetNumber(Com,Ctr);
  99.       end;
  100.       Inc(Ctr);
  101.     end;
  102.     if Note<1 then begin
  103.       Dec(ThisOct);
  104.       Note:=12;
  105.     end else
  106.     if Note>12 then begin
  107.       Inc(ThisOct);
  108.       Note:=1;
  109.     end;
  110.     Frequency:=32.625;
  111.     for Ctr:=1 to ThisOct do
  112.       Frequency:=Frequency * 2;
  113.     for Ctr:=1 to Note - 1 do
  114.       Frequency:=Frequency * 1.059463094;
  115.     if ThisLen <> 0.0 then
  116.     begin
  117.       if Step then NoSound;
  118.       Sound(Round(Frequency));
  119.       Delay(Round(ThisLen*(256-Tempo)*15*Music)*Ord(not ScrlLk));
  120.     end
  121.     else Sound(Round(Frequency));
  122.   end;
  123.  
  124. begin
  125.   NoSound;
  126.   NoSpaces(ComLin);
  127.   ComLinPos:=1; Command:='';
  128.   repeat
  129.     GetShiftStats;
  130.     Command:=GetSymbol(ComLin,ComLinPos,Comms+Notes);
  131.     if KeyPressed and TitleMusic then TuneStopped:=True;
  132.     if(Command <> '') then begin
  133.       if Command [1] in Comms then ProcessCommand(Command)
  134.         else if Command [1] in Notes then PlayNote(Command);
  135.     end;
  136.     Inc(ComLinPos, Length(Command));
  137.   until(ComLinPos > Length(ComLin)) or TuneStopped;
  138.   NoSound;
  139. end;
  140.